home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / screen / aboutw / about.bas next >
BASIC Source File  |  1995-02-10  |  12KB  |  417 lines
  1. Option Explicit
  2.  
  3.     Type RECT
  4.     Left As Integer
  5.     Top As Integer
  6.     Right As Integer
  7.     Bottom As Integer
  8.     End Type
  9.  
  10.     Global Const GWW_HINSTANCE = (-6)
  11.     
  12.     Global Const RDW_INVALIDATE = &H1
  13.     Global Const RDW_ERASE = &H4
  14.     Global Const RDW_ALLCHILDREN = &H80
  15.  
  16.     Global Const COLOR_BACKGROUND = 1
  17.     Global Const COLOR_ACTIVECAPTION = 2
  18.     
  19.     Declare Function GetFreeSpace& Lib "Kernel" (ByVal wFlags%)
  20.     Declare Function GetFreeSystemResources% Lib "User" (ByVal fuSysResource%)
  21.     Declare Function GetWinFlags& Lib "Kernel" ()
  22.     Declare Function GetVersion& Lib "Kernel" ()
  23.     Declare Function GetModuleHandle% Lib "Kernel" (ByVal lpModuleName$)
  24.     Declare Function LoadString% Lib "User" (ByVal hInstance%, ByVal wID%, ByVal lpBuffer$, ByVal nBufferMax%)
  25.     Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%)
  26.     Declare Function CreateSolidBrush% Lib "GDI" (ByVal crColor&)
  27.     Declare Function DeleteObject% Lib "GDI" (ByVal hObject%)
  28.     Declare Function GetDC% Lib "User" (ByVal hWnd%)
  29.     Declare Sub GetWindowRect Lib "User" (ByVal hWnd%, lpRect As RECT)
  30.     
  31.     Declare Sub InflateRect Lib "User" (lpRect As RECT, ByVal X%, ByVal Y%)
  32.     Declare Function GetDesktopWindow% Lib "User" ()
  33.     Declare Function CreateRectRgnIndirect% Lib "GDI" (lpRect As RECT)
  34.     Declare Function RedrawWindow% Lib "User" (ByVal hWnd%, lprcUpdate As RECT, ByVal hrgnUpdate%, ByVal fuRedraw%)
  35.     Declare Function FrameRgn% Lib "GDI" (ByVal hDC%, ByVal hRgn%, ByVal hBrush%, ByVal nWidth%, ByVal nHeight%)
  36.     Declare Function GetSysColor& Lib "User" (ByVal nIndex%)
  37.     
  38.     Declare Function Rectangle% Lib "GDI" (ByVal hDC%, ByVal X1%, ByVal Y1%, ByVal X2%, ByVal Y2%)
  39.     Declare Function ReleaseDC% Lib "User" (ByVal hWnd%, ByVal hDC%)
  40.     Declare Function GetWindowsDirectory% Lib "Kernel" (ByVal lpBuffer$, ByVal nSize%)
  41.     Declare Function GetSystemDirectory% Lib "Kernel" (ByVal lpBuffer$, ByVal nSize%)
  42.     Declare Function GetCurrentTask% Lib "Kernel" ()
  43.     Declare Function GetModuleFileName% Lib "Kernel" (ByVal hModule%, ByVal lpFilename$, ByVal nSize%)
  44.     Declare Function GetWindowWord% Lib "User" (ByVal hWnd%, ByVal nIndex%)
  45.     Declare Function ExtractIcon% Lib "Shell" (ByVal hInst%, ByVal FileName$, ByVal iIcon%)
  46.     Declare Function DestroyIcon% Lib "user" (ByVal hIcon%)
  47.     Declare Function GlobalSize& Lib "kernel" (ByVal hGlobal%)
  48.     Declare Function GlobalLock& Lib "kernel" (ByVal hGlobal%)
  49.     Declare Function GlobalUnlock% Lib "kernel" (ByVal hGlobal%)
  50.     Declare Sub hmemcpy Lib "kernel" (ByVal hpDest&, ByVal hpSource&, ByVal cbCopy&)
  51.  
  52. Function AppIcon2Pic% (Pic As PictureBox)
  53.  
  54.     Dim hIcon%
  55.     Dim Rc%
  56.     Dim hInst%
  57.  
  58.     hInst% = GetWindowWord%(Pic.hWnd, GWW_HINSTANCE)
  59.     
  60.     hIcon% = ExtractIcon%(hInst%, ExeName$(hInst%), 0)
  61.     If hIcon% Then
  62.     AppIcon2Pic% = CopyIcon%(hIcon%, (Pic.Picture))
  63.     Rc% = DestroyIcon%(hIcon%)
  64.     End If
  65.  
  66. End Function
  67.  
  68. Sub ClearDesktop (MyRect As RECT)
  69.     
  70.     Dim hDeskTop%
  71.     Dim hDeskRgn%
  72.     Dim ret%
  73.     
  74.     hDeskTop% = GetDesktopWindow%()
  75.     hDeskRgn% = CreateRectRgnIndirect%(MyRect)
  76.     If hDeskRgn% Then
  77.     ret% = RedrawWindow%(hDeskTop%, MyRect, hDeskRgn%, RDW_ERASE + RDW_INVALIDATE + RDW_ALLCHILDREN)
  78.     ret% = DeleteObject%(hDeskRgn%)
  79.     End If
  80.  
  81. End Sub
  82.  
  83. Function CopyIcon% (hSource%, hDest%)
  84.     
  85. '~~~~~ Copies the icon from *hSource to *hDest, provided the
  86. '~~~~~ memory blocks at *hSource and *hDest are the same size.
  87. '~~~~~ hSource and hDest are Handles to Icons
  88.     
  89.     Dim sizeSource&, sizeDest&
  90.     Dim fpSource&, fpDest&
  91.     Dim Rc%
  92.     
  93.     CopyIcon% = False
  94.     
  95.     ' get size of memory blocks
  96.     sizeSource& = GlobalSize&(hSource%)
  97.     sizeDest& = GlobalSize&(hDest%)
  98.     
  99.     If sizeDest& <> sizeSource& Then
  100.     If sizeSource& <> 288 Then  ' not a monochrome icon
  101.         Exit Function
  102.     End If
  103.     End If
  104.     
  105.     ' lock memory and get far pointers to Source & Destination
  106.     fpSource& = GlobalLock&(hSource%)
  107.     fpDest& = GlobalLock&(hDest%)
  108.     
  109.     ' copy Source to Destination
  110.     hmemcpy fpDest&, fpSource&, sizeSource&
  111.     
  112.     ' unlock memory
  113.     Rc% = GlobalUnlock%(hDest)
  114.     Rc% = GlobalUnlock%(hSource)
  115.  
  116.     CopyIcon% = True
  117.  
  118. End Function
  119.  
  120. Function ExeName$ (hInst%)
  121.     
  122.     Dim Temp$
  123.     Dim NameLen%
  124.     
  125.     Temp$ = String(255, Chr$(0))
  126.     NameLen% = GetModuleFileName%(hInst%, Temp$, Len(Temp$))
  127.     If NameLen% Then
  128.     ExeName$ = Left$(Temp$, NameLen%)
  129.     Else
  130.     ExeName$ = "<Unknown>"
  131.     End If
  132.  
  133. End Function
  134.  
  135. Function FormatLong$ (TheNum&)
  136.     
  137.     Dim TheStr$
  138.  
  139.     TheStr$ = Space$(11)
  140.  
  141.     RSet TheStr$ = Format$(TheNum&, "###,###,##0")
  142.  
  143.     FormatLong$ = TheStr$
  144.  
  145. End Function
  146.  
  147. Sub FormCenter (Frm As Form)
  148.     
  149.     Dim TheTop%, TheLeft%
  150.  
  151.     TheTop% = (Screen.Height - Frm.Height) / 2
  152.     TheLeft% = (Screen.Width - Frm.Width) / 2
  153.  
  154.     Frm.Move TheLeft%, TheTop%
  155.  
  156. End Sub
  157.  
  158. Sub FormExplode (Frm As Form)
  159.  
  160. ' "explodes" a form by drawing successively larger rectangles,
  161. ' using the form's background color, to fill the form area.
  162. ' Should be called prior to show method
  163.  
  164. '~~~~~ Number of pixels to increase/decrease each time.
  165. '~~~~~ Smaller sizes result in a slower but smoother "explosion."
  166.     Const STEP_SIZE = 2
  167.  
  168.     Dim MyRect As RECT
  169.     Dim XLimit%
  170.     Dim YLimit%
  171.     Dim TheWidth%
  172.     Dim TheHeight%
  173.     Dim XInflate%
  174.     Dim YInflate%
  175.     Dim hDCScreen%
  176.     Dim hBrush%
  177.     Dim OldObj%
  178.     Dim ret%
  179.  
  180. '~~~~~ How big is the form?
  181.     GetWindowRect Frm.hWnd, MyRect
  182.  
  183. '~~~~~ We need to stay within this boundary
  184.     XLimit% = MyRect.Left%
  185.     YLimit% = MyRect.Top%
  186.     
  187. '~~~~~ Determine the rectangle at the center of the form
  188.     TheWidth% = MyRect.Right% - MyRect.Left%
  189.     TheHeight% = MyRect.Bottom% - MyRect.Top%
  190.     InflateRect MyRect, (TheWidth% \ 2) * -1, (TheHeight% \ 2) * -1
  191.  
  192. '~~~~~ Get right proprtion of vertical and horizontal
  193. '~~~~~ increments
  194.     If TheWidth% > TheHeight% Then
  195.     XInflate% = STEP_SIZE
  196.     YInflate% = XInflate% * (TheWidth% / TheHeight%)
  197.     Else
  198.     YInflate% = STEP_SIZE
  199.     XInflate% = YInflate% * (TheHeight% / TheWidth%)
  200.     End If
  201.  
  202. '~~~~~ Get the screen's device context.
  203.     hDCScreen% = GetDC%(0)
  204.  
  205.     If hDCScreen% Then
  206.     '~~~~~ Create a solid brush that uses the form's background color.
  207.     hBrush% = CreateSolidBrush%(Frm.BackColor)
  208.     If hBrush% Then
  209.         OldObj% = SelectObject%(hDCScreen%, hBrush%)
  210.     '~~~~~ Draw successively larger rectangles
  211.         Do While (MyRect.Left% > XLimit%) And (MyRect.Top% > YLimit%)
  212.         ret% = Rectangle%(hDCScreen%, MyRect.Left%, MyRect.Top%, MyRect.Right%, MyRect.Bottom%)
  213.         InflateRect MyRect, XInflate%, YInflate%
  214.         Loop
  215.     '~~~~~ Restore the DC
  216.         If OldObj% Then
  217.         OldObj% = SelectObject%(hDCScreen%, OldObj%)
  218.         End If
  219.     '~~~~~ Delete the brush
  220.         ret% = DeleteObject%(hBrush%)
  221.     End If
  222.     '~~~~~ Release the device context and brush
  223.     ret% = ReleaseDC%(0, hDCScreen%)
  224.     End If
  225.     
  226. End Sub
  227.  
  228. Sub FormImplode (Frm As Form)
  229.  
  230. ' "implodes" a form by drawing successively smaller rectangles,
  231. ' using the form's background color
  232. ' Should be called instead of Hide method
  233.  
  234. '~~~~~ Number of pixels to increase/decrease each time.
  235. '~~~~~ Smaller sizes result in a slower but smoother "implosion."
  236.     Const STEP_SIZE = 3
  237.  
  238.     Dim MyRect As RECT
  239.     Dim SaveRect As RECT
  240.     Dim XLimit%
  241.     Dim YLimit%
  242.     Dim TheWidth%
  243.     Dim TheHeight%
  244.     Dim XInflate%
  245.     Dim YInflate%
  246.     Dim XBorder%
  247.     Dim YBorder%
  248.     Dim hDeskTop%
  249.     Dim hDCScreen%
  250.     Dim hBrush%
  251.     Dim hBrush2%
  252.     Dim hBrush3%
  253.     Dim hDeskRgn%
  254.     Dim Clr&
  255.     Dim OldObj%
  256.     Dim ret%
  257.  
  258. '~~~~~ How big is the form?
  259.     GetWindowRect Frm.hWnd, MyRect
  260.     SaveRect = MyRect
  261.     
  262. '~~~~~ Determine the rectangle at the center of the form
  263.     TheWidth% = MyRect.Right% - MyRect.Left%
  264.     TheHeight% = MyRect.Bottom% - MyRect.Top%
  265.     InflateRect MyRect, (TheWidth% \ 2) * -1, (TheHeight% \ 2) * -1
  266.  
  267. '~~~~~ This is as far as we will go
  268.     XLimit% = MyRect.Left%
  269.     YLimit% = MyRect.Top%
  270.  
  271.     MyRect = SaveRect
  272.     
  273. '~~~~~ Get right proprtion of vertical and horizontal
  274. '~~~~~ increments
  275.     If TheWidth% > TheHeight% Then
  276.     XInflate% = STEP_SIZE
  277.     YInflate% = XInflate% * (TheWidth% / TheHeight%)
  278.     Else
  279.     YInflate% = STEP_SIZE
  280.     XInflate% = YInflate% * (TheHeight% / TheWidth%)
  281.     End If
  282.  
  283.     XBorder% = XInflate%
  284.     YBorder% = YInflate%
  285.  
  286. '~~~~~ Cause us to decrease in size
  287.     XInflate% = XInflate% * -1
  288.     YInflate% = YInflate% * -1
  289.  
  290. '~~~~~ Get the screen's device context.
  291.     'hDeskTop% = GetDesktopWindow%()
  292.     hDeskTop% = 0
  293.     hDCScreen% = GetDC%(hDeskTop%)
  294.  
  295.     If hDCScreen% Then
  296.     '~~~~~ Need a brush that looks like the form's background.
  297.     hBrush% = CreateSolidBrush%(Frm.BackColor)
  298.     '~~~~~ Another that matche the background of the desktop
  299.     Clr& = GetSysColor&(COLOR_BACKGROUND)
  300.     hBrush2% = CreateSolidBrush%(Clr&)
  301.     '~~~~~ And one that looks like the form's border.
  302.     Clr& = GetSysColor&(COLOR_ACTIVECAPTION)
  303.     hBrush3% = CreateSolidBrush%(Clr&)
  304.     '~~~~~ If we have all of them
  305.     If hBrush% And hBrush2% And hBrush3% Then
  306.     '~~~~~ Set up to draw "form background"
  307.         OldObj% = SelectObject%(hDCScreen%, hBrush%)
  308.     '~~~~~ Make it look like a form
  309.         ret% = Rectangle%(hDCScreen%, MyRect.Left%, MyRect.Top%, MyRect.Right%, MyRect.Bottom%)
  310.         hDeskRgn% = CreateRectRgnIndirect%(MyRect)
  311.         If hDeskRgn% Then
  312.         ret% = FrameRgn%(hDCScreen%, hDeskRgn%, hBrush3%, XBorder%, YBorder%)
  313.         ret% = DeleteObject%(hDeskRgn%)
  314.         End If
  315.     '~~~~~ Now that we covered it, hide the form
  316.         Frm.Hide
  317.     '~~~~~ Draw successively larger rectangles
  318.         Do While (MyRect.Left% < XLimit%) And (MyRect.Top% < YLimit%)
  319.         
  320.         '~~~~~ Make the old rect look like the desktop
  321.         hDeskRgn% = CreateRectRgnIndirect%(MyRect)
  322.         If hDeskRgn% Then
  323.             ret% = FrameRgn%(hDCScreen%, hDeskRgn%, hBrush2%, XBorder%, YBorder%)
  324.             ret% = DeleteObject%(hDeskRgn%)
  325.         End If
  326.         '~~~~~ Crank it down one step
  327.         InflateRect MyRect, XInflate%, YInflate%
  328.         '~~~~~ Make it look like a form
  329.         ret% = Rectangle%(hDCScreen%, MyRect.Left%, MyRect.Top%, MyRect.Right%, MyRect.Bottom%)
  330.         hDeskRgn% = CreateRectRgnIndirect%(MyRect)
  331.         If hDeskRgn% Then
  332.             ret% = FrameRgn%(hDCScreen%, hDeskRgn%, hBrush3%, XBorder%, YBorder%)
  333.             ret% = DeleteObject%(hDeskRgn%)
  334.         End If
  335.         Loop
  336.  
  337.         ClearDesktop SaveRect
  338.  
  339.         '~~~~~ Make the old rect look like the desktop
  340.         hDeskRgn% = CreateRectRgnIndirect%(MyRect)
  341.         If hDeskRgn% Then
  342.             ret% = FrameRgn%(hDCScreen%, hDeskRgn%, hBrush2%, XBorder%, YBorder%)
  343.             ret% = DeleteObject%(hDeskRgn%)
  344.         End If
  345.     
  346.     '~~~~~ Restore the DC
  347.         If OldObj% Then
  348.         OldObj% = SelectObject%(hDCScreen%, OldObj%)
  349.         End If
  350.     '~~~~~ Delete the brushes
  351.         ret% = DeleteObject%(hBrush%)
  352.         ret% = DeleteObject%(hBrush2%)
  353.         ret% = DeleteObject%(hBrush3%)
  354.     End If
  355.     '~~~~~ Release the device context and brush
  356.     ret% = ReleaseDC%(hDeskTop%, hDCScreen%)
  357.     End If
  358.  
  359. End Sub
  360.  
  361. Sub main ()
  362.  
  363.     Dim ProductName$
  364.     Dim ProductVersion$
  365.     Dim Copyright$
  366.  
  367.     ProductName$ = "AboutWin"
  368.     ProductVersion$ = "1.1a"
  369.     Copyright$ = "Copyright ⌐ 1994 by XYZ."
  370.     
  371.     Load frmAbout
  372.     frmAbout!lblVersion.Caption = ProductName$ & " Version " & ProductVersion$ & " is licensed to:"
  373.     frmAbout!lblCopyright.Caption = Copyright$
  374.     Call FormExplode(frmAbout)
  375.     frmAbout.Show
  376.  
  377. End Sub
  378.  
  379. Sub ShowAbout (ProductId$, Copyright$)
  380.     
  381.     Load frmAbout
  382.     Call FormExplode(frmAbout)
  383.     frmAbout.Show
  384.  
  385. End Sub
  386.  
  387. Function SysDir$ ()
  388.     
  389.     Dim Temp$
  390.     Dim NameLen%
  391.     
  392.     Temp$ = String(255, Chr$(0))
  393.     NameLen% = GetSystemDirectory%(Temp$, Len(Temp$))
  394.     If NameLen% Then
  395.     SysDir$ = Left$(Temp$, NameLen%)
  396.     Else
  397.     SysDir$ = "<Unknown>"
  398.     End If
  399.  
  400. End Function
  401.  
  402. Function WinDir$ ()
  403.     
  404.     Dim Temp$
  405.     Dim NameLen%
  406.     
  407.     Temp$ = String(255, Chr$(0))
  408.     NameLen% = GetWindowsDirectory%(Temp$, Len(Temp$))
  409.     If NameLen% Then
  410.     WinDir$ = Left$(Temp$, NameLen%)
  411.     Else
  412.     WinDir$ = "<Unknown>"
  413.     End If
  414.  
  415. End Function
  416.  
  417.